perm filename MARKZ.F4[NEW,LCS]7 blob sn#539623 filedate 1980-10-03 generic text, type T, neo UTF8
00100	C**** MARKZ -- XREAD (FOR MARKZ,SLURZ) -- ZNOTE -- MARKS
00200	
00300		SUBROUTINE MARKZ
00400		COMMON /XRN/RN(1)
00500		1 /RINP/R(10,85),POSNT(0/99) /RMOD/RMODE2,SET4,IBEAM,
00600		1 NOSET,STEM,STUP,NTC,PS2,RAM,RDD,IT,POS /ALF/INP(72),ML
00700		1 /LIMIT/LIMIT,ITEM,LL,IS,IX  /MX/MX,MZ
00800		1 /SCM/V(78),I,LCNT,STAFF,LIST(200),REND
00900		1 /SCX/JALPHA(7),ISTAR,JAL(22),JX,U,JZ,IRHY,JD,KA,KB,IZ
01000		1 /SC/J,L,MK,ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JA,DBST,NFLG
01100		1 ,JXX,ISEMI,IQT,VX(50),IAMP,K,KN,M,MODE,IBLA
01200	
01300		INVT=-1
01400		MX=0
01500		JNTC=NTC-1
01600	C  JNTC=NUM OF NTS NOW
01700		JREP=-1
01800	C  JREP IS FOR REPEAT FEATURE IN 'MARKS'
01900	25	CALL XREAD
02000		IF(VX(1).EQ.0)CALL NEWMRK(VX,MX)
02100	C ABOVE FOR NEW MARKS INPUT FORMAT.
02200	505	L=0
02300		K=0
02400		POS=-10.
02500	5032	IF(N.LE.JNTC)GO TO 5030
02600		N=JNTC  
02700	C TRAPS ERROR OF TRYING TO PUT MARK ON NON-EXISTENT NOTE.
02800		VX(J)=N
02900	C VX(J)=N IS NEEDED AT LABEL 130  
03000	5030	L=L+1
03100	502	K=K+1
03200		IF(R(1,K).NE.1.)GO TO 502
03300	C  IS IT A NOTE?
03400		P=R(3,K)
03500		IF(P.EQ.POS)GO TO 502
03600	C  SKIPS DBLSTPS
03700		POS=P
03800	506	IF(L.LT.N)GO TO 5030
03900	30	IF(JREP)CALL MARKS(RA)
04000		RB=0
04100		J=J+1
04200	CXXX	IF(RA.GE.30.AND.RA.LE.35)VX(J+1)=0
04300	C THIS  ↑↑↑↑ CATCHES FINGERING NUM.(0-5)  IT WAS READ IN MARKS.
04400		IF(RA.EQ.99)RA=VX(J)
04500	C  IF STEM IS DOWN OR THERE ARE NOTES BELOW(DBL STP), POSITION
04600	C    OF ACCENT WILL BE INVERTED.
04700	130	IF(RA.LT.37)GO TO 304
04800	C  37=RIT.
04900		C=POSIT(VX(J-1))
05000	
05100		IF(RA.LE.60.OR.RA.GT.63)GO TO 308
05200	C NEXT FOR TREMOLO: TM, TME, TMS, =32ND, 8TH, 16TH
05300		NN=11
05400		A=8
05500	C A IS WDCNT-2
05600		B=6
05700	C CODE NUM. IS IN B
05800	CXCX	C=C+1.5
05900	C FIND POSITION OF THIS NOTE
06000		BB=R(4,K)
06100	C  BB=HEIGHT
06200		RC=AMOD(R(7,K),10.0)
06300	C LOOK FOR TAILS
06400		X=0
06500		IF(RA.EQ.61)X=1
06600	C RA=61= 8TH NOTE BEAM
06700		AA=R(8,K)
06800	C TREM. POS. WILL DEPEND ON NOTE POS. AND STEM LENGTH
06900		IF(AA.NE.0)GO TO 2309
07000		AA=1-X
07100		R(8,K)=1.2-X
07200	2309	AA=AA-1  
07300	C  AA = AMOUNT TO BE ADDED OR SUBTRACTED  WITH HEIGHT OF NOTE
07400		IF(R(5,K).GE.20)GO TO 1309
07500	C CHECK ON STEM DIRECTION
07600		X=-(RA-50)
07700	C MAKES -11, -12, -13, ETC.
07800		IF(RC.NE.0)BB=BB-2
07900		GO TO 309
08000	1309	X=-(RA-40)
08100	C MAKES -21, -22, ETC.
08200		AA=-AA
08300		IF(RC.NE.0)BB=BB+2
08400	309	BB=BB+AA
08500	C OK FOR 16TH AND 32ND - BUT 8TH NEEDS MORE WORK******
08600		RC=0
08700		RN(IS+9)=0   
08800		RN(IS+10)=0
08900	C ABOVE IS TO LEAVE ROOM FOR CHANGE OF TREM TO BE PARALLEL TO OTHER BM.
09000		GO TO 305
09100	
09200	308	IF(RA.LT.100)C=C-1.5
09300	C  '-1.5' PUSHES IT TO LEFT. MAYBE CHANGE ORIGINAL POSITIONS??
09400		NN=6
09500		RC=RA
09600		BB=-6
09700		A=3
09800		B=3
09900		IF(XNOTE(K).LT.3)BB=XNOTE(K)-7.5
10000	C LOWERS ITEM IF NOTE BELOW STAFF.  BUT IS 'K' ALWAYS OK HERE??????
10100		IF(RA.LT.99)GO TO 305
10200	C NEXT FOR CRESC. & DECRSC. LINES<,>. TYPE /NT1 C+ NT2/ OR /N1.d  C- N2.d/
10300	C ALSO FOR "8va ----" /NT1 O NT2/
10400		NN=8
10500		BB=BB+2.5
10600		A=5
10700		B=4
10800		RB=50
10900		IF(RA.NE.208)GO TO 306
11000		RB=0
11100		B=7
11200		BB=15
11300	C  LATER ADD CHECK FOR HEIGHT OF NOTES UNDER 8va.
11400	306	X=RA-200
11500	C  MAKES ZERO OR -1 OR 8 IN P7
11600		RC=RB
11700	C  ADDS A NEW ITEM.  MP, PP, CRESC., ETC. --CODE 3
11800	305	CALL RNX(A,B,STAFF,C,BB,RC,0,X,0)
11900	C RNX FILLS PARAMS 0→8
12000		IS=IS+NN
12100		IF(B.EQ.3.OR.B.EQ.6)GO TO 230
12200	C B=6=TREM. NN=6=WORDS OR LTRS. UNDER STAFF.
12300	1	J=J+1
12400		IF(VX(J).EQ.0)GO TO 1
12500	C ABOVE FOR NEW MARKS FORMAT.  (I HOPE IT'S COMPATIBLE WITH OLD!)
12600		RC=POSIT(VX(J))
12700		IF(RB.EQ.0)RC=RC+3
12800	C RB=0= 8va
12900		RN(IS-2)=RC
13000	C  THIS IS P6 (POS2 FOR CRESC. LINES)
13100	514	J=J+1
13200		A=VX(J)
13300		N=A
13400	C  SO ITEMS NEED NOT BE IN RIGHT ORDER.
13500		IF(MOD(N,100).GT.IRHY)A=0
13600		IF(A.NE.0)GO TO 505
13700	CC***USE NO NUMBS IN COMMENTS IN MODE 3-5******	IF(VX(J+2).EQ.0)GO TO 614
13800		IF(J.LT.50)GO TO 514
13900	C  SOMETIMES A SLASH IS SEEN AS A 0 (WHEN PRECEDED BY SPACE).
14000	614	IF(INP(72).NE.ISTAR)GO TO  552
14100	
14200	714	IF(INVT)RETURN
14300		INVT=IS
14400	 	CALL NEWR
14500		IS=INVT
14600		RETURN
14700	552	IF(MX.EQ.0)GO TO 553
14800	C GO GET REST OF LINE THAT WAS TOO LONG FOR NEW FORMAT
14900		CALL MORMRK(MX,MZ,VX)
15000		J=1
15100		MX=0
15200	CC	INP(72)='*'
15300		GO TO 505
15400	553	CALL BMREAD
15500	C  TO READ MORE THAN 2 LINES.
15600		GO TO 25
15700	
15800	
15900	304	RB=R(2,K)
16000		IF(RA.EQ.6)RA=26.
16100		A=RA
16200		IF(RB.EQ.0)GO TO 301
16300		IF(RB.GE.10)GO TO 303
16400		A=A*100
16500		GO TO 301
16600	303	RB=RB*100
16700	301	R(2,K)=RB+A
16800	C  P11 INFO(MARKS) IS TEMPORARILY STORED IN P2 (STAFF# IS IN STAFF)
16900	230	A=VX(J)
17000		JREP=-1
17100		IF(A.EQ.0)GO TO 514
17200	C NEXT FOR STRING OF SAME MARK ( /3 12 S/ )
17300		IF(A.GT.JNTC)A=JNTC
17400	C WON'T PUT MARK BEYOND LAST NOTE
17500		JREP=0
17600		J=J-1
17700		VX(J)=VX(J)+1
17800		IF(VX(J).GE.A)VX(J+1)=0
17900		J=J-1
18000		GO TO 514
18100	C   USES 4-7,9,11-13 FOR ACC. > FERM. DOT - DNBOW UPBOW HARM.
18200	C  NOTE#,ACCENT#/N,A/N,A*
18300		END
18400	
18500	
18600		SUBROUTINE XREAD
18700		COMMON /FRMT/F78F(1),FA1(1),FA5(1),IREAD /ALF/INP(72)
18800		1 /SCX/JALPHA(7),ISTAR,JAL(22),JX,U,JZ,IRHY,JD,KA,KB,IZ
18900		1 /SC/J,L,MK,ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JA,DBST,NFLG
19000		1 ,JXX,ISEMI,IQT,VX(50),IAMP,K
19100		1 /A2Z/IAZ(5),LEF
19200		DO 1500 K=1,72
19300		J=INP(K)
19400		IF(J.NE.LEF)GO TO 1
19500	CHECK TO SEE IF A NUMBER FOLLOWS 'F' (FINGERING)(F0=FU  F5=FZ)
19600		L=INP(K+1)
19700		IF(ISNUM(L).LT.0)GO TO 1
19800		INP(K+1)=IAZ(NALF(L)+21)
19900	1	IF(J.EQ.ISTAR)GO TO 15  
20000	1500	IF(J.EQ.ISEMI)GO TO 500
20100	15	INP(72)=ISTAR
20200	C ABOVE FOR 2ND LNE OF INPUT. IF LNS ENDS WITHOUT * OR ;, IT PUTS IN *
20300	C  *******  1ST MAIN LOOP *********
20400	CXCX 500	REREAD F78F,VX
20500	500	CALL RREAD(INP,VX)
20600	CC	J=0
20700	CC	IF(IREAD.EQ.-1)J=1
20800	C  SKIPS LINE #S IN SOS FILES. (=-2 IS FOR ET FILES.)
20900	CC	J=J+1
21000		J=1
21100		N=VX(1)
21200		END
21300	 
21400		FUNCTION ZNOTE(K)
21500	C ADJUSTS HEIGHT IN RE. TO STAFF ABOVE OR BELOW AND SPECIFIED STEM DIR.
21600		COMMON /SCX/JALPHA(30),X /RINP/R(10,85)
21700		1 /RMOD/RMODE2,SET4,IBEAM,NOSET,STEM,STUP,NTC,PS2,RAM,JSTEM
21800		ZNOTE=XNOTE(K)
21900		IF(JSTEM.GT.K)RETURN
22000		L=R(10,K)
22100		IF(L.EQ.0)RETURN
22200		M=X/10.
22300		IF(M.EQ.0)RETURN
22400		IF(M.EQ.L)RETURN
22500		M=R(5,K)/10.
22600	C ASSUMES SPECIFIED STEM DIR. IS CORRECT
22700		A=0
22800		IF(L.EQ.1)GO TO 1
22900		IF(M.EQ.2)A=-14.
23000		GO TO 2
23100	1	IF(M.EQ.1)A=14.
23200	2	ZNOTE=ZNOTE+A
23300		END
23400	
23500		SUBROUTINE MARKS(RA)
23600		COMMON/ALF/INP(72),ML  /JCHAR/IXX,ISEMX,IBLA
23700		1 /MKS/MKS(14) /MKX/KSLA,ISEMI,NONO(7),MINUS,ISTAR
23800		1 /A2Z/A1(4),LEE,A2(6),LEL,LMM,LNN,A3(6),LEU,LV,LW,LX,LY,LEZ
23900		1 /SCX/ICOM,MINU,IDOT,IEQ,LPRN,IRPRN,IPLUS
24000		1 /SC/J,NO(15),VX(50)
24100		EQUIVALENCE (MF,MKS(3)),(MH,MKS(9)),(MP,MKS(11)),(MM,MKS(5))
24200		1,(MC,MKS(12)),(MR,MKS(13)),(MI,MKS(10)),(MS,MKS(4))
24300		1,(MO,MKS(14)),(MW,MKS(1))
24400		RA=99
24500		DO 16 JM=1,72
24600	16	IF(INP(JM))GO TO 17
24700	C  DIDN'T FIND  MORE LETTERS
24800		RETURN
24900	17	N=INP(JM)
25000		ML=INP(JM+1)
25100		M=INP(JM+2)
25200		DO 1 K=1,14
25300	1	IF(N.EQ.MKS(K))GO TO 2
25400	C  DID NOT FIND A LETTER
25500		RETURN
25600	C 4=W(EDGE),5=A(CCENT),26=FE(RMATA),7=S(TACCATO),9=T(ENUTO)
25700	C 11=D(OWNBOW), 12=U(PBOW),13=H(ARMONIC),14=PL(US),15=TH(ESIS)
25800	C 16=AR(SIS),17=MO(RDANT)
25900	C 18=I(NVRTD MORD), ---,20=TR(ILL), 21=TRF(LAT), 22=TRS(HARP)
26000	C 23=TRN(ATURAL),  >39=PPP, PP, CRESC., ETC.
26100	C 25=HW (HEAVY WEDGE), 80=ACC(EL.)  FICTA:5=FLAT, 2=#, 3=NAT.
26200	C 27=TS(TEN.+STAC.)   28=WS(WEDGE+STAC.)  29=AS(ACCENT+STACCATO)
26300	2	GO TO(220,10,12,120,4,11,15,15,15,21,12,80,81,87),K
26400	12	IF(ML.EQ.LEL)GO TO 320
26500	C  ↑↑↑ PLUS
26600		IF(N.EQ.MF)GO TO 121
26700		RA=42
26800		IF(ML.NE.MP)GO TO 18
26900		RA=41
27000		IF(M.EQ.MP)RA=40
27100	C  FOR P, PP, PPP  -- 42, 41, 40
27200		GO TO 18
27300	220	IF(ML.EQ.MS)K=25  
27400	C 'WS' = WEDGE+STACCATO =28
27500		GO TO 320
27600	15	IF(ML.EQ.MI)GO TO 82
27700		K=K+1
27800		IF(ML.EQ.MW)K=22
27900	C 'HW' MAKES 25  (EVENTUALLY MAKES CLEF# 44)
28000	120	IF(ML.EQ.MF)GO TO 88
28100	320	K=K+3
28200	8	RA=K
28300	C  YOU CAN TYPE # OR NAME OF MARK
28400	18	DO 6 JM=1,72
28500		N=INP(JM)
28600		INP(JM)=IBLA
28700	C  BLANKS OUT USED LETTERS
28800		IF(N.EQ.KSLA)RETURN
28900		IF(N.EQ.ISTAR)RETURN
29000	6	IF(N.EQ.ISEMI)RETURN
29100	4	IF(ML.EQ.MO)GO TO 20
29200		RA=43
29300		IF(ML.EQ.MF)RA=50
29400	C  ↑↑↑↑↑ MP, MF
29500		GO TO 18
29600	121	IF(ML.EQ.LEE)GO TO 320
29700	C  ↑↑↑  FERMATA
29800		RA=51
29900		IF(ML.EQ.MF)RA=52
30000		IF(ML.EQ.MP)RA=54
30100		IF(M.EQ.MF)RA=53
30200	C  F, FF, FFF, FP  -- 51, 52, 53, 54  --- SF=45, SFZ=92
30300		IF(ML.NE.MI)GO TO 22
30400	C TYPE FIF, FIS, FIN FOR FICTA flat, sharp, natural
30500		RA=1
30600		IF(M.EQ.MS)RA=2
30700		IF(M.EQ.LNN)RA=3
30800		GO TO 18
30900	22	IF(ML.GE.LEU.AND.ML.LE.LEZ)RA=30+(ML-LEU)/536870912
31000	C  TYPE /2 F0/6 F5/ FOR FINGERING NUMS. 0-5   FU=F0, FZ=F5
31100		GO TO 18
31200	88	RA=45
31300	C  FOR SF AND SFZ
31400		IF(INP(JM+2).EQ.LZZ)RA=92
31500		GO TO 18
31600	10	IF(ML.EQ.MC)GO TO 84
31700	C  'AC'=ACCEL.
31800		IF(ML.EQ.MR)K=13
31900	C  'AR' FOR ARSIS
32000		IF(ML.EQ.MS)K=26
32100	C 'AS'=ACCENT-STACCATO COMBO (=29)
32200		GO TO 320
32300	11	IF(ML.EQ.MH)K=12
32400	C THESIS
32500		IF(ML.NE.MM)GO TO 110
32600		K=60
32700		IF(M.EQ.LEE)K=58
32800		IF(M.EQ.MS)K=59
32900	C TM=TREMOLO,3 BEAMS=63 AT LABEL 8
33000	C TME, TMS: 61=1 BEAM, 62=2 BEAMS
33100	110	IF(ML.NE.MR)GO TO 111
33200		K=17
33300	C TR(ILL)=20 TRF(LAT)=21 TRS(HARP)=22 TRN(ATRL)=23
33400		IF(M.EQ.MF)K=18
33500		IF(M.EQ.MS)K=19
33600		IF(M.EQ.LNN)K=20
33700		GO TO 320
33800	111	IF(ML.EQ.MS)K=24
33900	C TS=TEN.+STAC.=27
34000		GO TO 320
34100	20	K=17
34200		GO TO 8
34300	21	K=18
34400		GO TO 8
34500	CC80	IF(ML.EQ.IPLUS)GO TO 85
34600	CC	IF(ML.EQ.MINUS)GO TO 86
34700	C  FOR /N1 C+ N2/ ETC. -- CRESC. AND DECRESC. LINES.
34800	C '+' IS OPTIONAL.   2ND NUM. MEANS NOT 'CRESC.'
34900	80	IF(ML.EQ.MINUS)GO TO 86
35000		IF(ML.NE.MR)GO TO 85
35100	CRR***CX	IF(ML.NE.MR)GO TO 85
35200	CRR***	IF(VX(J+2).NE.0)GO TO 85
35300		RA=70
35400	C  'CR'='CRESC.'
35500		GO TO 18
35600	85	RA=200
35700		GO TO 18
35800	86	RA=199
35900		GO TO 18
36000	87	RA=208
36100		GO TO 18
36200	C  ↑↑↑ FOR /N1 OT N2/  8va
36300	81	RA=37
36400	C  RIT.
36500		GO TO 18
36600	82	RA=82
36700	C   DIM.
36800		GO TO 18
36900	84	RA=80
37000	C  ACCEL.
37100		GO TO 18
37200		END